#lang racket


(require (for-syntax (only-in srfi/1 list-index)))

(require (for-syntax "list.rkt"))

(provide lambda-shape
         define-shape)


(define-for-syntax (symbol->keyword s)
  (string->keyword (symbol->string s)))

(define-for-syntax (keyword->symbol s)
  (string->symbol (keyword->string s)))

(define (keyword->symbol s)
  (string->symbol (keyword->string s)))


(define-for-syntax (make-monadic-parameter clouds kws kw-args c)
  #`(#,c (hash-ref #,(car clouds)
                   '#,(syntax->datum c)
                   (λ () (error "Undefined variable" '#,(syntax->datum c))))))

(define-syntax (lambda-shape stx)
  (syntax-case stx ()
    ((_ (args ...) body ...)
     (let-values (((formals clouds)
                   (split-at
                    (syntax-e #'(args ...))
                    (list-index (λ (s) (eq? s '..)) (syntax->datum #'(args ...))))))
       #`(make-keyword-procedure
          (λ (kws kw-args . ac-args)
            (let ((#,(car clouds)
                   (foldr
                    (λ (kw kw-arg hash) (hash-set hash (keyword->symbol kw) kw-arg))
                    (last ac-args)
                    kws
                    kw-args)))
              
              (let #,(map (λ (c) (make-monadic-parameter clouds #'kws #'kw-args c)) (cdr clouds))
                (apply (λ (#,@formals #,(gensym)) body ...) ac-args)))))))))


(define-syntax (define-shape stx)
  (syntax-case stx ()
    ((_ (name args ...) body ...)
     #'(define name (lambda-shape (args ...) body ...)))))